C       MULTICOP.FOR
C               MULTICOP
C               ESKIP
C               FMTCOP
C               ERROR
C               SETSTA
C               FEXIT
C               AESSET
C               DOFORM
C----------------------------------------------------------------------
C                                  MULTICOP
C----------------------------------------------------------------------
C
C       Program to fast format and copy to disks
C
C       Read returns:
C       A       Initial entry
C       B       Abort read
C       C       Read error
C       D       Return form write form: write done
C       E       Exit from write form
C       F       End of HELP/ABORT
C       G       Boot block error
C       H       SPT/NTRACK error
C
C----------------------------------------------------------------------
C
        PROGRAM MULTICOP
        INCLUDE 'MULTICOP.INC'
        INCLUDE 'MULTICOP.JNC'
           
C   Local

        INTEGER*1 BNSTR(12),PKR1
        INTEGER*2 LINE(0:3),DL(0:7),PKR2(2)
        INTEGER*4 form_do,form_alert,objc_state
        INTEGER*4 I,J,K,K1,K2,XX,XXX,RES,RDRV,WDRV,NDRV,HANDLE
        INTEGER*4 EVENT,evnt_multi,objc_find,PMX,PMY,PMB,PKS,PKR,PBR
        INTEGER*4 IADSEC,NTRACK,ITRACK,IH,IS,IM,IDN,NN
        INTEGER*4 PX,PY,CXA(0:1),CYA(0:1)
        INTEGER*4 STATE(0:1)
        CHARACTER NAME*8,NSTR*12,ZERO*1
        CHARACTER*7 DISK(0:1)
        EQUIVALENCE (BNSTR,NSTR),(PKR2,PKR),(PKR2(2),PKR1)

C   Form parameters

        INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
        COMMON /FRM/OBJADD,FX,FY,FW,FH
        
        INTEGER*4 CADD,FADD,CX,CY,CW,CH,X,Y,W,H
        INTEGER*4 IBUT,HBUT
        EQUIVALENCE (CADD,OBJADD(0)),(FADD,OBJADD(1))
        EQUIVALENCE (CX,FX(0)),(X,FX(1))
        EQUIVALENCE (CY,FY(0)),(Y,FY(1))
        EQUIVALENCE (CW,FW(0)),(W,FW(1))
        EQUIVALENCE (CH,FH(0)),(H,FH(1))
        
        INTEGER*1 SECTOR0(512,20,85),BUF(10000),BTBK(512)
        INTEGER*1 SECTOR1(512,20,85)
        INTEGER*4 SPT,SPD,NSIDES
        INTEGER*4 WW,D1,D2,D3,D4,D5,D6,D7,D8,D9,D10,D11
        INTEGER*4 CDA1,CDA2,CDA3,CDA4,CDA5,CDA6,CDA7
        INTEGER*4 CDA8,CDA9,CDA10,CDA11
        INTEGER*4 CDB1,CDB2,CDB3,CDB4,CDB5,CDB6,CDB7
        INTEGER*4 CDB8,CDB9,CDB10,CDB11
        EQUIVALENCE (SECTOR0,BTBK)
        LOGICAL*4 RANNUM
        
        DATA NAME/'MULTICOP'/
        DATA DISK/'Disk A ','Disk B '/

        ZERO=CHAR(0)
        DISK(0)(7:7)=ZERO
        DISK(1)(7:7)=ZERO
                  
C-------------------------------------------------------------MULTICOP

C   Formats

1       FORMAT(I1)
2       FORMAT(I2)
4       FORMAT(I4)
10      FORMAT(I10)

C   Initialise AES

        CALL AESSET(HANDLE,NAME,-1,RES,OBJADD,FX,FY,FW,FH)
        CALL graf_mouse(0,0)
        CALL graf_mouse(256,0)                  !hide mouse
        CALL objc_offset(FADD,READBAR,PX,PY)
        CALL objc_offset(CADD,BARA,CXA(0),CYA(0))                
        CALL objc_offset(CADD,BARB,CXA(1),CYA(1))

C   Initialise states

        CALL objc_read(FADD,READBAR,D1,D2,D3,D4,D5,D6,D7,
     1                              D8,D9,D10,D11)
        CALL objc_read(CADD,BARA,CDA1,CDA2,CDA3,CDA4,CDA5,CDA6,CDA7,
     1                           CDA8,CDA9,CDA10,CDA11)
        CALL objc_read(CADD,BARB,CDB1,CDB2,CDB3,CDB4,CDB5,CDB6,CDB7,
     1                           CDB8,CDB9,CDB10,CDB11)
     
C   Start with mouse showing

        CALL graf_mouse(257,0)

C-------------------------------------------------------------------
C                              Set up read form

C   Define read form;  hide mouse

2000    CALL form_dial(0,0,0,0,0,X,Y,W,H)       !open dialog box

C   Hide mouse & clear read statistics and read button

        CALL ESKIP(0,1,*2100)               !Type A return

C   Draw read form

2100    CALL objc_draw(FADD,0,32767,X,Y,W,H)
        
C--------------------------------------------------------------------
C                       Process read form

1000    CALL graf_mouse(257,0)
        IBUT=form_do(FADD,0)
        CALL graf_mouse(256,0)
        IF (IBUT.NE.READIT)
     1    CALL objc_change(FADD,IBUT,0,X,Y,W,H,0,.TRUE.)
            
C   Analyse exits
C   Abort

        IF (IBUT.EQ.EXITR) THEN
          CALL FEXIT(HANDLE,X,Y,W,H)

C   Give help

        ELSE IF (IBUT.EQ.HELP) THEN
          CALL form_dial(3,0,0,0,0,X,Y,W,H)       !close box
          CALL DOFORM(2,HBUT,0)
          IF (HBUT.EQ.MORE) CALL DOFORM(3,HBUT,0)
          CALL form_dial(0,0,0,0,0,X,Y,W,H)
          CALL objc_draw(FADD,0,32767,X,Y,W,H)
          GOTO 1000                               !Type F return

C   Abort

        ELSE IF (IBUT.EQ.ABORTR) THEN
          GOTO 1000                               !rType F return
          
C   Read the disk
        
        ELSE
  
      
C   Get the disk

          RDRV=objc_state(FADD,DISKB)

C   Read the disk number flag

          RANNUM=(objc_state(FADD,YESDN).GT.0)
          
C   Read boot block of master disk

          CALL FLOPRD(K,BTBK,RDRV,1,0,0,1)
          IF (K.NE.0) THEN
            I=form_alert(1,'[3][Error in boot block][Abort]')
            CALL objc_change(FADD,IBUT,0,X,Y,W,H,0,.TRUE.)
            GOTO 1000                           !Type G return
          END IF
          
          IADSEC=IADDR(SECTOR0)
 
C   Get Sectors/track: SPT
         
          K1=(IPEEK1(IADSEC+25).AND.255)
          CALL ISHFT(K1,K1,8)
          K2=(IPEEK1(IADSEC+24).AND.255)
          SPT=(K1.OR.K2)

C   Get sectors/disk: SPD

          K1=(IPEEK1(IADSEC+20).AND.255)
          CALL ISHFT(K1,K1,8)
          K2=(IPEEK1(IADSEC+19).AND.255)
          SPD=(K1.OR.K2)

C   Get number of sides: NSIDES

          K1=(IPEEK1(IADSEC+27).AND.255)
          CALL ISHFT(K1,K1,8)
          K2=(IPEEK1(IADSEC+26).AND.255)
          NSIDES=(K1.OR.K2)

C   Get disk number

          I=BTBK(9).AND.255
          J=BTBK(10).AND.255
          K=BTBK(11).AND.255
          IDN=K+256*(J+256*I)

C   Get number of tracks: NTRACK

          NTRACK=SPD/(SPT*NSIDES)

C   Display some statistics
C   First drive name

          CALL objc_newtext(FADD,SOURCE,DISK(RDRV))
          CALL objc_draw(FADD,SOURCE,0,X,Y,W,H)
          
C   Sectors/track

          WRITE(NSTR(1:2),2) SPT
          BNSTR(3)=0
          CALL objc_newtext(FADD,SPTT,NSTR)
          CALL objc_draw(FADD,SPTT,32767,X,Y,W,H)

C   Sectors/disk

          WRITE(NSTR(1:4),4) SPD
          BNSTR(5)=0
          CALL objc_newtext(FADD,SPDT,NSTR)
          CALL objc_draw(FADD,SPDT,0,X,Y,W,H)

C   Sides/disk
          
          WRITE(NSTR(1:1),1) NSIDES
          BNSTR(2)=0
          CALL objc_newtext(FADD,SIPDT,NSTR)
          CALL objc_draw(FADD,SIPDT,0,X,Y,W,H)

C   Tracks/side

          WRITE(NSTR(1:2),2) NTRACK
          BNSTR(3)=0
          CALL objc_newtext(FADD,TDDT,NSTR)
          CALL objc_draw(FADD,TDDT,0,X,Y,W,H)

C   Test SPT and NTRACK

          IF (SPT.GT.11.OR.NTRACK.GT.85) THEN
            IF (SPT.GT.11)
     1        I=form_alert(1,'[3][Too many sectors/track][Abort]')
            IF (NTRACK.GT.85)
     1        I=form_alert(1,'[3][Too many tracks][Abort]')
            CALL ESKIP(1,0,*1000)            !Type H return
          END IF  

C   Disk #

          WRITE(NSTR(1:10),10) IDN
          BNSTR(11)=0
          CALL objc_newtext(FADD,DISKN,NSTR)
          CALL objc_draw(FADD,DISKN,0,X,Y,W,H)
          
          IF (RANNUM) THEN
            CALL TIME(IH,IM,IS,IH)
            XX=RANDOM(IM*60+IS)
          END IF

C   Set up progress bar X coordinate and box size

          WW=2*NTRACK+1
          IF (WW.NE.D10) THEN
            CALL objc_write(FADD,READBAR,D1,D2,D3,D4,D5,D6,D7,
     1                                   D8,D9,WW-2,D11)
            CALL objc_draw(FADD,READBAR,0,X,Y,W,H)          
            CALL objc_write(CADD,BARA,CDA1,CDA2,CDA3,CDA4,CDA5,CDA6,
     1                      CDA7,CDA8,CDA9,WW,CDA11)
            CALL objc_write(CADD,BARB,CDB1,CDB2,CDB3,CDB4,CDB5,CDB6,
     1                      CDB7,CDB8,CDB9,WW,CDB11)
          END IF      

C   OK, Read in entire disk looping over tracks but testing 
C   for an abort at each track

          NN=0                          !count of done copies
          XXX=PX+1                      !X coordinate of progress bar
          LINE(1)=PY
          LINE(3)=PY+D11-1
          CALL graf_mouse(257,0)        !show the mouse
          
          DO 400 ITRACK=0,NTRACK-1
            EVENT=evnt_multi(35,1,1,1,
     1                       0,0,0,0,0,0,0,0,0,0,DL,
     2                       1,PMX,PMY,PMB,PKS,PKR,PBR)
            IF (EVENT.NE.32) THEN
              IF ((EVENT.AND.1).EQ.1) THEN
                IF (PKR1.EQ.1) CALL ESKIP(1,1,*1000)   !ESC: Type B return  
              ELSE IF ((EVENT.AND.2).EQ.2) THEN
                I=objc_find(FADD,ABORTR,0,PMX,PMY)
                IF (I.EQ.ABORTR) CALL ESKIP(1,1,*1000) !abrt: Type B return    
              END IF  
            END IF
            
C   Read side 1

            CALL FLOPRD(K,SECTOR0(1,1,ITRACK+1),RDRV,1,ITRACK,0,SPT)
            IF (K.NE.0) THEN
              CALL ERROR(1,K,ITRACK,1)
              CALL ESKIP(1,1,*1000)       !Type C return
            END IF

C   Read side 2 if NSIDES=2

            IF (NSIDES.EQ.2) THEN
              CALL FLOPRD(J,SECTOR1(1,1,ITRACK+1),RDRV,1,ITRACK,1,SPT)
              IF (K.NE.0) THEN
                CALL ERROR(1,J,ITRACK,2)
                CALL ESKIP(1,1,*1000)       !Type C return
              END IF
            END IF

C   Draw a vertical line in the progess bar
            
            LINE(0)=XXX
            LINE(2)=XXX
            CALL v_pline(HANDLE,2,LINE)
            XXX=XXX+2
            
400       CONTINUE
        END IF 

C   The master disk has been read
C   Close form 2 (leave mouse showing)

        CALL objc_newstate(FADD,IBUT,0)
        CALL form_dial(3,0,0,0,0,X,Y,W,H)       !close FADD

C---------------------------------------------------------------------
C                             Format/Write form (0)

C   Initialise states in form 1 (the mouse still shows)

        CALL SETSTA(STATE,0,1)
        CALL SETSTA(STATE,1,1)
        CALL objc_newtext(CADD,TOTCOP,'0'//ZERO)

C   Open and draw form 1 (FM=0)

        CALL form_dial(0,0,0,0,0,CX,CY,CW,CH)
        CALL objc_draw(CADD,0,32767,CX,CY,CW,CH)
        
C   Wait for A or B

        NDRV=-1
510     EVENT=evnt_multi(3,1,1,1,
     1                   0,0,0,0,0,0,0,0,0,0,DL,
     2                   1,PMX,PMY,PMB,PKS,PKR,PBR)

C   A keypress
       
        IF ((EVENT.AND.1).EQ.1) THEN
          IF (PKR1.EQ.28) THEN               !RETURN: Back to form 1
            GOTO 3000                           !Type E return
          ELSE IF (PKR1.EQ.30.OR.PKR1.EQ.48) THEN
            WDRV=IDIM(PKR1-47,0)             !A/B
            CALL SETSTA(STATE,WDRV,3)
          ELSE
            GOTO 510
          END IF            

C   A mouse click

        ELSE IF ((EVENT.AND.2).EQ.2) THEN
          IF (objc_find(CADD,EXIT,0,PMX,PMY).EQ.EXIT) THEN
            GOTO 3000                           !Type E return
          ELSE IF (objc_find(CADD,DRIVEA,0,PMX,PMY).EQ.DRIVEA) THEN
            WDRV=0
            CALL SETSTA(STATE,WDRV,3)           !Drive A button
          ELSE IF (objc_find(CADD,DRIVEB,0,PMX,PMY).EQ.DRIVEB) THEN
            WDRV=1
            CALL SETSTA(STATE,WDRV,3)           !Drive B button
          ELSE
            GOTO 510
          END IF            
        END IF  

C   Write to disk WDRV  

        IF (WDRV.EQ.0.OR.WDRV.EQ.1) THEN
520       I=CYA(WDRV)
          LINE(0)=CXA(WDRV)+1
          LINE(1)=I
          LINE(3)=I+CDA11-1

          CALL FMTCOP(SECTOR0,SECTOR1,BUF,BTBK,
     1                      SPT,NSIDES,WDRV,NDRV,NTRACK,
     2                      RANNUM,HANDLE,LINE,STATE,NN,IDN)
          IF (NDRV.NE.-1) THEN          !there is a disk ready
            WDRV=NDRV
            NDRV=-1
            GOTO 520
          ELSE                          !no disks ready
            GOTO 510
          END IF  
        END IF
        CALL BELL
             
C   Close CADD form; return for another lot

3000    CALL objc_newstate(CADD,IBUT,0)
        CALL form_dial(3,0,0,0,0,CX,CY,CW,CH)

C   Return with mouse showing and all forms closed

        GOTO 2000                               !Type D return
        END
 
C-------------------------------------------------------------------
C                              ESKIP                
C-------------------------------------------------------------------
C
C       Subroutine to tidyup after a read abort or error by:
C       1.      If MSE is true, Hiding mouse
C       2.      Deselecting READIT button
C       3       Redrawing READIT is DRAW is true
C       4.      Clearing read stats
C       5       Redrawing stats if DRAW is true
C
C-------------------------------------------------------------------

        SUBROUTINE ESKIP(DRAW,MSE,*)
        INCLUDE 'MULTICOP.INC'
        INCLUDE 'MULTICOP.JNC'
        
        INTEGER*4 DRAW,MSE
        
        INTEGER*4 I,STATS(6),STL(6)
        LOGICAL*4 BDRAW
        CHARACTER BLANK*12,ZERO*1
        

        INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
        COMMON /FRM/OBJADD,FX,FY,FW,FH
        INTEGER*4 FADD,X,Y,W,H
        EQUIVALENCE (FADD,OBJADD(1))
        EQUIVALENCE (X,FX(1))
        EQUIVALENCE (Y,FY(1))
        EQUIVALENCE (W,FW(1))
        EQUIVALENCE (H,FH(1))
        
        DATA BLANK/'            '/
        DATA STATS/SPTT,SPDT,SIPDT,TDDT,DISKN,SOURCE/
        DATA STL/2,4,1,2,10,7/
        
        ZERO=CHAR(0)
        
C--------------------------------------------------------------ESKIP

        BDRAW=(DRAW.EQ.1)
        IF (MSE.EQ.1) THEN
          CALL graf_mouse(256,0)          !hide mouse
          IF (BDRAW) CALL objc_draw(FADD,READBAR,0,X,Y,W,H)
        END IF  
        DO 200 I=1,6
          CALL objc_newtext(FADD,STATS(I),BLANK(1:STL(I))//ZERO)
          IF (BDRAW) CALL objc_draw(FADD,STATS(I),0,X,Y,W,H)
200     CONTINUE
        CALL objc_change(FADD,READIT,0,X,Y,W,H,0,BDRAW)  
        RETURN 1        
        END

        
C---------------------------------------------------------------------
C                              FMTCOP
C---------------------------------------------------------------------
C
C       Subroutine to copy/format a disk in drive WDRV
C
C       WDRV  Current working drive A=0, B=1
C
C       The mouse shows throughout this routine.
C       The form (CADD) is neither opened or closed
C
C---------------------------------------------------------------------

        SUBROUTINE FMTCOP(SECTOR0,SECTOR1,BUF,BTBK,
     1                    SPT,NSIDES,WDRV,NDRV,NTRACK,
     2                    RANNUM,HANDLE,LINE,STATE,NN,IDN)
        INCLUDE 'MULTICOP.INC'
        INCLUDE 'MULTICOP.JNC'

        INTEGER*1 SECTOR0(512,11,85),BUF(10000),BTBK(512)
        INTEGER*1 SECTOR1(512,11,85)
        INTEGER*4 SPT,NSIDES,WDRV,NDRV,NTRACK
        INTEGER*4 HANDLE,STATE(0:1)
        INTEGER*2 LINE(0:3)
        INTEGER*4 NN,IDN
        LOGICAL*4 RANNUM
        
        INTEGER*1 IB1,JB1,KB1,II1(4),JJ1(4),KK1(4)
        INTEGER*4 I,J,K,JDN,ITRACK,IA,IB,BAR(0:1),XXX,KDRV,NEWS
        INTEGER*4 EVENT,evnt_multi,objc_find,PMX,PMY,PMB,PKS,PKR,PBR
        INTEGER*4 COPN(0:1),DISN(0:1)
        INTEGER*2 DL(0:7),PKR2(2)
        INTEGER*1 PKR1
        CHARACTER STNN*4,STDIS*12,ZERO*1
        EQUIVALENCE (PKR2,PKR),(PKR2(2),PKR1)
        EQUIVALENCE (I,II1),(J,JJ1),(K,KK1)
        EQUIVALENCE (IB1,II1(4)),(JB1,JJ1(4)),(KB1,KK1(4))       
                             
C   Form parameters

        INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
        COMMON /FRM/OBJADD,FX,FY,FW,FH
        
        INTEGER*4 CADD,CX,CY,CW,CH
        EQUIVALENCE (CADD,OBJADD(0))
        EQUIVALENCE (CX,FX(0))
        EQUIVALENCE (CY,FY(0))
        EQUIVALENCE (CW,FW(0))
        EQUIVALENCE (CH,FH(0))

        DATA COPN/COPNA,COPNB/
        DATA DISN/DISKNA,DISKNB/
        DATA BAR/BARA,BARB/
        
        ZERO=CHAR(0)
        STNN(4:4)=ZERO
        STDIS(11:11)=ZERO

C---------------------------------------------------------------FMTCOP

C   Formats

1       FORMAT(I1)
2       FORMAT(I2)
3       FORMAT(I3)
10      FORMAT(I10)
        
C   Put random disk number in BTBK if required

        IF (RANNUM) THEN
          I=IFIX(256.*RANDOM(0)).AND.255
          J=IFIX(256.*RANDOM(0)).AND.255
          K=IFIX(256.*RANDOM(0)).AND.127
          JDN=K+256*(J+256*K)
          BTBK(9)=IB1                           !L606=446+160
          BTBK(10)=JB1
          BTBK(11)=KB1
        ELSE
          JDN=IDN
        END IF  

C   Clear bar & initialise

        CALL objc_draw(CADD,BAR(WDRV),0,CX,CY,CW,CH)
        XXX=LINE(0)

C   Reset state to working

        CALL SETSTA(STATE,WDRV,3)
        
C   Set up for formatting and copying

        NEWS=4                                      !default done flag
        NN=NN+1                                     !increment copy count

C   Enter and draw copy # and disk #

        WRITE(STNN(1:3),3) NN
        CALL objc_newtext(CADD,COPN(WDRV),STNN)
        CALL objc_draw(CADD,COPN(WDRV),0,CX,CY,CW,CH)
        WRITE(STDIS(1:10),10) JDN                   !disk number
        CALL objc_newtext(CADD,DISN(WDRV),STDIS)
        CALL objc_draw(CADD,DISN(WDRV),0,CX,CY,CW,CH)
        
C   Format and copy track by track

        DO 300 ITRACK=0,NTRACK-1
        
C   Get an instruction to abort or ready a drive

            EVENT=evnt_multi(35,1,1,1,
     1                       0,0,0,0,0,0,0,0,0,0,DL,
     2                       1,PMX,PMY,PMB,PKS,PKR,PBR)

C   A keypress

            IF (EVENT.NE.32) THEN
              IF ((EVENT.AND.1).EQ.1) THEN
                IF (PKR1.EQ.1) THEN               !ESC: Abort
                  NEWS=6
                  GOTO 500
                ELSE IF (PKR1.EQ.30.OR.PKR1.EQ.48.AND.NDRV.EQ.-1) THEN
                  KDRV=IDIM(PKR1-47,0)            !A/B: Ready a drive
                  IF (STATE(KDRV).NE.3) THEN
                    NDRV=KDRV
                    CALL SETSTA(STATE,NDRV,2)  !A/B: ready it
                  END IF
                END IF            

C   A mouse click

              ELSE IF ((EVENT.AND.2).EQ.2) THEN       !Abort
                IF (objc_find(CADD,RESET,0,PMX,PMY).EQ.RESET) THEN
                  NEWS=6
                  GOTO 500
                ELSE IF
     1            (objc_find(CADD,DRIVEA,0,PMX,PMY).EQ.DRIVEA) THEN
                  IF (STATE(0).NE.3) THEN
                    NDRV=0
                    CALL SETSTA(STATE,NDRV,2)  !Ready
                  END IF
                ELSE IF
     1            (objc_find(CADD,DRIVEB,0,PMX,PMY).EQ.DRIVEB) THEN
                  IF (STATE(1).NE.3) THEN
                    NDRV=1
                    CALL SETSTA(STATE,NDRV,2)  !Ready
                  END IF  
                END IF            
              END IF
            END IF    

C   Format side 1

          CALL FLPFMT(K,BUF,WDRV,SPT,ITRACK,0,0)
          IF (K.NE.0) THEN
            CALL ERROR(2,K,ITRACK,1)
            NEWS=5                              !error flag
            GOTO 500
          END IF
          
C   Write SECTOR0 to it

          CALL FLOPWR(K,SECTOR0(1,1,ITRACK+1),WDRV,1,ITRACK,0,SPT)
          IF (K.NE.0) THEN
            CALL ERROR(3,K,ITRACK,1)
            NEWS=5                              !error flag
            GOTO 500
          END IF

C   Format side 2 if NSIDES=2

          IF (NSIDES.EQ.2) THEN
            CALL FLPFMT(K,BUF,WDRV,SPT,ITRACK,1,0)
            IF (K.NE.0) THEN
              CALL ERROR(2,K,ITRACK,2)
              NEWS=5                            !error flag
              GOTO 500
            END IF

C   Write SECTOR1 to it

            CALL FLOPWR(K,SECTOR1(1,1,ITRACK+1),WDRV,1,ITRACK,1,SPT)
            IF (K.NE.0) THEN
              CALL ERROR(3,K,ITRACK,2)
              NEWS=5                            !error flag
              GOTO 500
            END IF
          END IF
          
C   Enter a progress bar
        
          LINE(0)=XXX
          LINE(2)=XXX
          CALL v_pline(HANDLE,2,LINE)
          XXX=XXX+2

300     CONTINUE
        
C   Reset state to done, empty or faulty and decrement 

500     IF (NEWS.GE.5) NN=NN-1              !not done: abort/faulty
        CALL SETSTA(STATE,WDRV,NEWS)        !done, aborted or faulty

C   Enter total copies made

        WRITE(STNN(1:3),3) NN
        CALL BELL
        CALL objc_newtext(CADD,TOTCOP,STNN)
        CALL objc_draw(CADD,TOTCOP,0,CX,CY,CW,CH)

        END

C---------------------------------------------------------------------
C                               ERROR
C---------------------------------------------------------------------
C
C       Subroutine show form alert with error source
C
C---------------------------------------------------------------------

        SUBROUTINE ERROR(EN,K,TRACK,SIDE)

        INTEGER*4 EN,K,TRACK,SIDE
        
        INTEGER*4 I,form_alert
        INTEGER*2 POS(3)
        CHARACTER*52 STR(3)
        CHARACTER ZERO*1
        
        DATA POS/16,22,19/
        DATA STR/
     1    '[3][Read error nnn|on track nn|side n][Abort]',
     2    '[3][Formatting error nnn|on track nn|side n][Abort]',
     3    '[3][Writing error nnn|on track nn|side n][Abort]'/
        
        ZERO=CHAR(0)
        STR(1)(46:46)=ZERO   
        STR(2)(52:52)=ZERO
        STR(3)(49:49)=ZERO
                     
C----------------------------------------------------------------ERROR

3       FORMAT(I3)
2       FORMAT(I2)
1       FORMAT(I1)
        
        I=POS(EN)
        WRITE(STR(EN)(I:I+2),3) K
        I=I+13
        WRITE(STR(EN)(I:I+1),2) TRACK
        I=I+8
        WRITE(STR(EN)(I:I),1) SIDE
        I=form_alert(1,STR(EN))

        END
        
C---------------------------------------------------------------------
C                               SETSTA
C---------------------------------------------------------------------
C
C       Subroutine to set the sate of drive DRV to state NEWSTA and
C       draw text STATEX(NEWSTA) into object STAOBJ(DRIVE)
C
C---------------------------------------------------------------------

        SUBROUTINE SETSTA(STATE,DRIVE,NEWSTA)
        INCLUDE 'MULTICOP.INC'
        INCLUDE 'MULTICOP.JNC'
             
        INTEGER*4 STATE(0:1),DRIVE,NEWSTA
        
        INTEGER*4 KST,COP,DIS
        INTEGER*4 STAOBJ(0:1),COPN(0:1),DISN(0:1),BARN(0:1)
        CHARACTER*7 STATEX(6)
        CHARACTER ZERO*1
        INTEGER*1 BZERO
        EQUIVALENCE (BZERO,ZERO)
        
        INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
        COMMON /FRM/OBJADD,FX,FY,FW,FH

        INTEGER*4 CADD,CX,CY,CW,CH
        EQUIVALENCE (CADD,OBJADD(0))
        EQUIVALENCE (CX,FX(0)),(CY,FY(0)),(CW,FW(0)),(CH,FH(0))
                
        DATA STAOBJ/STATEA,STATEB/
        DATA STATEX/'Waiting','Ready  ','Working',
     1              'Done   ','Faulty ','Aborted'/
        DATA COPN/COPNA,COPNB/
        DATA DISN/DISKNA,DISKNB/
        DATA BARN/BARA,BARB/
        DATA BZERO/0/
        
C----------------------------------------------------------------SETSTA

        STATE(DRIVE)=NEWSTA

C   Redraw status In all cases)

        KST=STAOBJ(DRIVE)
        CALL objc_newtext(CADD,KST,STATEX(NEWSTA)//ZERO)
        IF (NEWSTA.GT.1)  CALL objc_draw(CADD,KST,0,CX,CY,CW,CH)

C   Reset stats 
        
        IF (NEWSTA.LE.2) THEN
          COP=COPN(DRIVE)
          DIS=DISN(DRIVE)
          CALL objc_newtext(CADD,COP,'   '//ZERO)
          CALL objc_newtext(CADD,DIS,'          '//ZERO)

C   Redraw stats and bar for NEWSTA=2 only

          IF (NEWSTA.EQ.2) THEN
            CALL objc_draw(CADD,COP,0,CX,CY,CW,CH)
            CALL objc_draw(CADD,DIS,0,CX,CY,CW,CH)
            CALL objc_draw(CADD,BARN(DRIVE),0,CX,CY,CW,CH)
          END IF
        END IF  
        END
        
C---------------------------------------------------------------------
C                               FEXIT
C---------------------------------------------------------------------
C
C       Subroutine to close down form and AES and exit
C
C---------------------------------------------------------------------

        SUBROUTINE FEXIT(HANDLE,X,Y,W,H)
        
        INTEGER*4 HANDLE,X,Y,W,H
        
C----------------------------------------------------------------FEXIT

        CALL v_clsvwk(HANDLE)                   !close virtual work station
        CALL form_dial(3,0,0,0,0,X,Y,W,H)       !close box
        CALL rsrc_free                          !free tree memory
        CALL graf_mouse(257,0)                  !show mouse as we exit
        CALL appl_exit                          !exit AES
        STOP
        END
       
C------------------------------------------------------------------
C                               AESSET
C------------------------------------------------------------------
C
C       A subroutine for setting up AES applications
C
C       Input:
C               NAME    Character string of .RSC name
C               NMENU   I*4 Muenu object # or -1 if none
C               NF      Highest form number
C
C       Output:
C               RES     Resolution, 1 = medium; 2 = high
C               OBJADD  Array of form addresses
C               FX,FY   Arrays of form coordinates
C               FW,FH   Arrays of form sizes
C
C       The object (form & menu) addresses are put in OBJADD
C       and the cooerdinates in FX,FY,FW,FH
C
C------------------------------------------------------------------

        SUBROUTINE AESSET(HANDLE,NAME,NMENU,RES,OBJADD,FX,FY,FW,FH)
        INCLUDE 'MULTICOP.JNC'
                
        CHARACTER NAME*8
        INTEGER*4 HANDLE,NMENU,RES
        INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
       
        INTEGER*4 AESret,form_alert,graf_handle,dummy
        INTEGER*2 work_in(0:10),work_out(0:56)
        INTEGER*4 XBIOS
        INTEGER*2 BUFFER(0:7)
       
        INTEGER*4 I,IBUT,L
        
C------------------------------------------------------------------

C   Initialise application with AES

        CALL appl_init
        IF (AESret() .lt. 0) GOTO 999

C   Test resolution

        BUFFER(0)=4
        L=LENGTH(NAME)
        RES=XBIOS(BUFFER)
        IF (RES.EQ.0) THEN
          dummy=form_alert(1,'[3]['//NAME(1:L)//
     1                       ' cannot be used in|'//
     2                           'low resolution; change|'//
     3                           'to medium and try again]'//
     4                           '[OK]'//CHAR(0))
          GOTO 998 
        END IF       
        
C   Load resource file (must have extension)

        CALL rsrc_load(NAME(1:L)//'.RSC'//CHAR(0))
        IF (AESret().EQ.0) THEN
          DUMMY = form_alert(1, '[3]['//NAME(1:L)//
     1                          '.RSC cannot be found]'//
     2                          '[ OK ]' // char(0))
          GOTO 998
        END IF 

C   Get addresses and sizes of all forms

        DO 100 I=0,NF
          CALL rsrc_gaddr(0,I,OBJADD(I))
          IF (I.NE.NMENU) 
     1      CALL form_center(OBJADD(I),FX(I),FY(I),FW(I),FH(I))
100     CONTINUE        
        
C   Get handle of desktop workstation

        HANDLE=graf_handle(dummy,dummy,dummy,dummy)

C   Initialise work_in
          
        work_in(0)=RES+2
        DO 200 I=1,9
          work_in(I)=1
200     CONTINUE
        work_in(7)=0                    !fill style 0
        work_in(10)=2                   !raster coordinates

C   Open a virtual workstation with handle of physical WS in HANDLE
C     HANDLE is returned with new handle to VWS.
C     work_out contains parameters of VWS

        CALL v_opnvwk(work_in,HANDLE,work_out)
        IF (HANDLE.EQ.0) THEN
          Dummy = form_alert(1, '[3][Error:'//
     1                          '|Work station could not be opened]'//
     1                          '[ OK ]' // char(0))
          GOTO 997
        END IF
C   Return OK

        RETURN
        
C   Tidyup for anomalous exit and stop

997     CALL rsrc_free                          !free tree memory
998     CALL appl_exit                          !exit AES
999     STOP
        END
        
C----------------------------------------------------------------
C                              DOFORM
C----------------------------------------------------------------
C   Subroutine to:
C
C       Reserve space for form of address FADD
C       Display form
C       Process form -  cursor first to object IFL
C       Reset state of exit button
C       Delete form space
C
C--------------------------------------------------------------DOFORM

        SUBROUTINE DOFORM(FN,IBUT,IFL)
        INCLUDE 'MULTICOP.JNC'
        
        INTEGER*4 FN,IBUT,IFL
       
        INTEGER*4 I,form_do
        
C   Form data

        INTEGER*4 OBJADD(0:NF),FX(0:NF),FY(0:NF),FW(0:NF),FH(0:NF)
        COMMON /FRM/OBJADD,FX,FY,FW,FH
        
        INTEGER*4 FADD,X,Y,H,W

C----------------------------------------------------------------DOFORM

C   Get address and coordinates of form

        FADD=OBJADD(FN)
        X=FX(FN)
        Y=FY(FN)
        W=FW(FN)
        H=FH(FN)
        
C   Define area of form; draw the form; process form;
C   restore exit button

        CALL form_dial(0,0,0,0,0,X,Y,W,H)
111     CALL objc_draw(FADD,0,32767,X,Y,W,H)
        CALL graf_mouse(257,0)
        IBUT=form_do(FADD,IFL)
        CALL graf_mouse(256,0)
        CALL objc_newstate(FADD,IBUT,0)
200     CALL form_dial(3,0,0,0,0,X,Y,W,H)
               
        END
        

